home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 002 / chedit.arc / PCHR.I < prev    next >
Text File  |  1986-07-23  |  16KB  |  388 lines
  1. {
  2.    This program is placed in the public domain by its author, William Couture.
  3.    Copyright (c) 1986 by DDI.    All Rights Reserved.
  4. }
  5.  
  6. type charset = array[0..1023] of byte;  { character set array definition }
  7.      filename = string[80];  { a function must be passed a type }
  8.      charmessage = array[0..79] of integer;  { a message "string" }
  9.  
  10. var coldseg,coldaddr:integer;   { you can rename these to whatever you want,
  11.                                   as long as you change the references in the 
  12.                                   getvect and restorevect routines. }
  13.  
  14. function readcset(var shapes:charset; fname:filename):integer;
  15.    var charfile: file of byte;
  16.        i:integer;
  17.        io:integer;
  18.    begin
  19.       assign(charfile,fname);
  20.       {$I-}
  21.       reset(charfile);
  22.       io := ioresult;
  23.       if (io = 0) then
  24.          begin
  25.             i := 0;
  26.             while((i < 1024) and (io = 0)) do
  27.                begin
  28.                   read(charfile,shapes[i]);
  29.                   io := ioresult;
  30.                   i := i+1;
  31.                end;
  32.          end;
  33.       if (io = 0) then
  34.          readcset := 1  { everything OK }
  35.       else
  36.          readcset := -1;  { something is wrong }
  37.       {$I+}
  38.       close(charfile);
  39.    end;
  40.  
  41. function writecset(var shapes:charset; fname:filename):integer;
  42.    var charfile: file of byte;
  43.        i:integer;
  44.        io:integer;
  45.    begin
  46.       assign(charfile,fname);
  47.       {$I-}
  48.       rewrite(charfile);
  49.       io := ioresult;
  50.       i := 0;
  51.       while ((i < 1024) and (io = 0)) do
  52.          begin
  53.             write(charfile,shapes[i]);
  54.             io := ioresult;
  55.             i := i+1;
  56.          end;
  57.       if (io = 0) then
  58.          writecset := 1  { everything OK }
  59.       else
  60.          writecset := -1;  { something is wrong }
  61.       {$I+}
  62.       close(charfile);
  63.    end;
  64.  
  65.  
  66. procedure getvect;  { save the system vector before starting }
  67.    begin
  68.       coldaddr := memw[0:124];
  69.       coldseg := memw[0:126];
  70.    end;
  71.  
  72. procedure setvect(var shapes:charset);  { set the vector to point to a table
  73.                                        defined by the programmer }
  74.    begin
  75.       memw[0:124] := ofs(shapes);
  76.       memw[0:126] := seg(shapes);
  77.    end;
  78.  
  79. procedure restorevect;  { restore the system vector }
  80.    begin
  81.       memw[0:124] := coldaddr;
  82.       memw[0:126] := coldseg;
  83.    end;
  84.  
  85. procedure setbit(var shapes:charset; whichchar,row,col:integer);
  86.                  { NOTE: row,col are from 0..7, not 1..8
  87.                          whichchar is 0..127 }
  88.    begin
  89.       inline($c4/$5e/<shapes/$8b/$46/<whichchar/$d1/$e0/$d1/$e0/$d1/$e0/
  90.              $03/$46/<row/$03/$d8/$b9/$07/$00/$2b/$4e/<col/$b0/$01/$d2/
  91.              $e0/$26/$08/$07);
  92.    end;
  93.  
  94. procedure clearbit(var shapes:charset; whichchar,row,col:integer);
  95.                  { NOTE: row,col are from 0..7, not 1..8
  96.                          whichchar is 0..127 }
  97.    begin
  98.       inline($c4/$5e/<shapes/$8b/$46/<whichchar/$d1/$e0/$d1/$e0/$d1/$e0/
  99.              $03/$46/<row/$03/$d8/$b9/$07/$00/$2b/$4e/<col/$b0/$01/$d2/
  100.              $e0/$f6/$d0/$26/$20/$07);
  101.    end;
  102.  
  103. procedure xorbit(var shapes:charset; whichchar,row,col:integer);
  104.                  { NOTE: row,col are from 0..7, not 1..8
  105.                          whichchar is 0..127 }
  106.    begin
  107.       inline($c4/$5e/<shapes/$8b/$46/<whichchar/$d1/$e0/$d1/$e0/$d1/$e0/
  108.              $03/$46/<row/$03/$d8/$b9/$07/$00/$2b/$4e/<col/$b0/$01/$d2/
  109.              $e0/$26/$30/$07);
  110.    end;
  111.  
  112. procedure zerochar(var shapes:charset; whichchar:integer);
  113.                { NOTE: whichchar is 0..127 }
  114.    begin
  115.       inline($c4/$5e/<shapes/$8b/$7e/<whichchar/$d1/$e7/$d1/$e7/$d1/$e7/
  116.              $03/$fb/$fc/$b9/$08/$00/$33/$c0/$f3/$aa);
  117.    end;
  118.  
  119. procedure fillchar(var shapes:charset; whichchar:integer);
  120.                { NOTE: whichchar is 0..127 }
  121.    begin
  122.       inline($c4/$5e/<shapes/$8b/$7e/<whichchar/$d1/$e7/$d1/$e7/$d1/$e7/
  123.              $03/$fb/$fc/$b9/$08/$00/$b0/$ff/$f3/$aa);
  124.    end;
  125.  
  126. procedure inversechar(var shapes:charset; whichchar:integer);
  127.                { NOTE: whichchar is 0..127 }
  128.    begin
  129.       inline($c4/$5e/<shapes/$8b/$46/<whichchar/$d1/$e0/$d1/$e0/$d1/$e0/
  130.              $03/$d8/$b9/$08/$00/$26/$80/$37/$ff/$43/$e2/$f9);
  131.    end;
  132.  
  133. procedure copychar(var shapes:charset; fromchar,intochar:integer);
  134.                { NOTE: fromchar and intochar are 0..127 }
  135.    begin
  136.       inline($8c/$da/$c4/$5e/<shapes/$8c/$c0/$8e/$d8/$8b/$76/<fromchar/
  137.              $d1/$e6/$d1/$e6/$d1/$e6/$8b/$7e/<intochar/$d1/$e7/$d1/$e7/
  138.              $d1/$e7/$03/$f3/$03/$fb/$b9/$08/$00/$fc/$f3/$a4/$8e/$da);
  139.    end;
  140.  
  141. procedure horizflip(var shapes:charset; whichchar:integer);
  142.                { NOTE: whichchar is 0..127 }
  143.    begin
  144.       inline($c4/$5e/<shapes/$8b/$76/<whichchar/$d1/$e6/$d1/$e6/$d1/$e6/
  145.              $03/$de/$be/$00/$00/$b9/$04/$00/$26/$8a/$00/$f7/$de/$83/$c6/
  146.              $07/$26/$8a/$20/$26/$88/$00/$83/$ee/$07/$f7/$de/$26/$88/$20/
  147.              $46/$e2/$e7);
  148.    end;
  149.  
  150. procedure vertflip(var shapes:charset; whichchar:integer);
  151.                { NOTE: whichchar is 0..127 }
  152.    begin
  153.       inline($c4/$5e/<shapes/$8b/$46/<whichchar/$d1/$e0/$d1/$e0/$d1/$e0/
  154.              $03/$d8/$ba/$08/$00/$b9/$08/$00/$33/$c0/$26/$8a/$07/$d0/$c0/
  155.              $d0/$dc/$e2/$fa/$26/$88/$27/$43/$4a/$75/$eb);
  156.    end;
  157.  
  158. procedure exchangerc(var shapes:charset; whichchar:integer);
  159.                { NOTE: whichchar is 0..127 }
  160.    begin
  161.       inline($8b/$dc/$83/$eb/$02/$b9/$08/$00/$36/$c6/$07/$00/$4b/$e2/$f9/
  162.              $c4/$76/<shapes/$8b/$5e/<whichchar/$d1/$e3/$d1/$e3/$d1/$e3/
  163.              $03/$f3/$ba/$08/$00/$b9/$08/$00/$8b/$dc/$83/$eb/$02/$26/$8a/
  164.              $04/$d0/$c0/$36/$d0/$17/$4b/$e2/$f8/$46/$4a/$75/$e9/$83/$ee/
  165.              $08/$8b/$dc/$83/$eb/$02/$b9/$08/$00/$36/$8a/$07/$26/$88/$04/
  166.              $46/$4b/$e2/$f6);
  167.    end;
  168.  
  169. procedure shiftdown(var shapes:charset; whichchar:integer);
  170.                { NOTE: whichchar is 0..127 }
  171.    begin
  172.       inline($c4/$5e/<shapes/$8b/$46/<whichchar/$d1/$e0/$d1/$e0/$d1/$e0/
  173.              $03/$d8/$be/$07/$00/$b9/$07/$00/$26/$8a/$40/$ff/$26/$88/$00/
  174.              $4e/$e2/$f6/$26/$c6/$07/$00);
  175.    end;
  176.  
  177. procedure shiftup(var shapes:charset; whichchar:integer);
  178.                { NOTE: whichchar is 0..127 }
  179.    begin
  180.       inline($c4/$5e/<shapes/$8b/$76/<whichchar/$d1/$e6/$d1/$e6/$d1/$e6/
  181.              $03/$de/$be/$00/$00/$b9/$07/$00/$26/$8a/$40/$01/$26/$88/$00/
  182.              $46/$e2/$f6/$26/$c6/$47/$07/$00);
  183.    end;
  184.  
  185. procedure shiftleft(var shapes:charset; whichchar:integer);
  186.                { NOTE: whichchar is 0..127 }
  187.    begin
  188.       inline($c4/$5e/<shapes/$8b/$46/<whichchar/$d1/$e0/$d1/$e0/$d1/$e0/
  189.              $03/$d8/$b9/$08/$00/$26/$d0/$27/$43/$e2/$fa);
  190.    end;
  191.  
  192. procedure shiftright(var shapes:charset; whichchar:integer);
  193.                { NOTE: whichchar is 0..127 }
  194.    begin
  195.       inline($c4/$5e/<shapes/$8b/$46/<whichchar/$d1/$e0/$d1/$e0/$d1/$e0/
  196.              $03/$d8/$b9/$08/$00/$26/$d0/$2f/$43/$e2/$fa);
  197.    end;
  198.  
  199. procedure rotatedown(var shapes:charset; whichchar:integer);
  200.                { NOTE: whichchar is 0..127 }
  201.    begin
  202.       inline($c4/$5e/<shapes/$8b/$46/<whichchar/$d1/$e0/$d1/$e0/$d1/$e0/
  203.              $03/$d8/$83/$c3/$07/$26/$8a/$27/$b9/$07/$00/$26/$8a/$47/$ff/
  204.              $26/$88/$07/$4b/$e2/$f6/$26/$88/$27);
  205.    end;
  206.  
  207. procedure rotateup(var shapes:charset; whichchar:integer);
  208.                { NOTE: whichchar is 0..127 }
  209.    begin
  210.       inline($c4/$5e/<shapes/$8b/$46/<whichchar/$d1/$e0/$d1/$e0/$d1/$e0/
  211.              $03/$d8/$26/$8a/$27/$b9/$07/$00/$26/$8a/$47/$01/$26/$88/$07/
  212.              $43/$e2/$f6/$26/$88/$27);
  213.    end;
  214.  
  215. procedure rotateleft(var shapes:charset; whichchar:integer);
  216.                { NOTE: whichchar is 0..127 }
  217.    begin
  218.       inline($c4/$5e/<shapes/$8b/$46/<whichchar/$d1/$e0/$d1/$e0/$d1/$e0/
  219.              $03/$d8/$b9/$08/$00/$26/$d0/$07/$43/$e2/$fa);
  220.    end;
  221.  
  222. procedure rotateright(var shapes:charset; whichchar:integer);
  223.                { NOTE: whichchar is 0..127 }
  224.    begin
  225.       inline($c4/$5e/<shapes/$8b/$46/<whichchar/$d1/$e0/$d1/$e0/$d1/$e0/
  226.              $03/$d8/$b9/$08/$00/$26/$d0/$0f/$43/$e2/$fa);
  227.    end;
  228.  
  229. procedure grchar(whichchar,color:integer);
  230.                { NOTE: whichchar is 0..127 OR 128..255
  231.                        color is 0..3 in 320x200 mode, 0..1 in 640x200 mode
  232.                        Adding 128 ($80) to the color will XOR draw the
  233.                        character on top of the existing screen }
  234.                { Currently, this routine always turns on the high bit, making
  235.                  the character a graphics character.  If you wish to use
  236.                  0..127 as graphics characters and 128..255 as the regular
  237.                  characters, change the $0c after the <whichchar to a $04
  238.                  i.e. <whichchar/$0c becomes <whichchar/$04 }
  239.    begin
  240.       inline($b4/$09/$8a/$46/<whichchar/$0c/$80/$8a/$5e/<color/$b9/
  241.              $01/$00/$55/$cd/$10/$5d);
  242.    end;
  243.  
  244. procedure gratchar(row,col,whichchar,color:integer);
  245.                { NOTE: whichchar is 0..127 OR 128..255
  246.                        row is 1..25
  247.                        col is 1..40 in 320x200 mode, 1..80 in 640x200 mode
  248.                        color is 0..3 in 320x200 mode, 0..1 in 640x200 mode
  249.                        Adding 128 ($80) to the color will XOR draw the
  250.                        character on top of the existing screen }
  251.                { Currently, this routine always turns on the high bit, making
  252.                  the character a graphics character.  If you wish to use
  253.                  0..127 as graphics characters and 128..255 as the regular
  254.                  characters, change the $0c after the <whichchar to a $04
  255.                  i.e. <whichchar/$0c becomes <whichchar/$04 }
  256.    begin
  257.       inline($b4/$02/$8a/$76/<row/$fe/$ce/$8a/$56/<col/$fe/$ca/$b7/$00/$55/
  258.              $cd/$10/$5d/$b4/$09/$8a/$46/<whichchar/$0c/$80/$8a/$5e/<color/
  259.              $b9/$01/$00/$55/$cd/$10/$5d);
  260.    end;
  261.  
  262. procedure printbanner(row,col:integer; msg:charmessage; length,color:integer);
  263.            { display a row of graphics characters }
  264.            { Adding 128 ($80) to the color will XOR draw the characters on
  265.              top of the existing screen }
  266.    var i:integer;
  267.    begin
  268.       i := 0;
  269.       repeat
  270.          gratchar(row,col,msg[i],color);
  271.          col := col+1;
  272.          i := i+1;
  273.       until (i = length);
  274.    end;
  275.  
  276. procedure printcolumn(row,col:integer; msg:charmessage; length,color:integer);
  277.            { display a column of graphics characters }
  278.            { Adding 128 ($80) to the color will XOR draw the characters on
  279.              top of the existing screen }
  280.    var i:integer;
  281.    begin
  282.       i := 0;
  283.       repeat
  284.          gratchar(row,col,msg[i],color);
  285.          row := row+1;
  286.          i := i+1;
  287.       until (i = length);
  288.    end;
  289.  
  290. procedure bannerleft(var shapes:charset; var msg:charmessage; length:integer);
  291.            {  Rotate a banner 1 pixel left.  This routine changes the contents
  292.               of the character set, not the screen.  After the banner has been
  293.               rotate, it must be re-displayed for the change to be see on
  294.               the screen }
  295.    begin
  296.       inline($1e/$c5/$7e/<shapes/$c4/$56/<msg/$8b/$da/$26/$8b/$37/$d1/$e6/
  297.              $d1/$e6/$d1/$e6/$03/$f7/$83/$c6/$07/$b4/$00/$b9/$08/$00/$8a/$04/
  298.              $d1/$c0/$4e/$e2/$f9/$8b/$4e/<length/$49/$78/$20/$8b/$d9/$d1/$e3/
  299.              $03/$da/$26/$8b/$1f/$d1/$e3/$d1/$e3/$d1/$e3/$03/$df/$be/$07/$00/
  300.              $8a/$00/$d1/$c0/$88/$00/$4e/$79/$f7/$49/$79/$e0/$1f);
  301.    end;
  302.  
  303. procedure bannerright(var shapes:charset; var msg:charmessage; length:integer);
  304.            { Rotate a banner 1 pixel right.  This routine changes the contents
  305.              of the character set, not the screen.  After the banner has been
  306.              rotated, it must be re-displayed for the change to be seen on the
  307.              screen }
  308.    begin
  309.       inline($1e/$c5/$56/<shapes/$c4/$5e/<msg/$8b/$7e/<length/$4f/$78/$41/
  310.              $d1/$e7/$26/$8b/$31/$d1/$e6/$d1/$e6/$d1/$e6/$03/$f2/$83/$c6/$07/
  311.              $b4/$00/$b9/$08/$00/$8a/$04/$d1/$c8/$4e/$e2/$f9/$8b/$cf/$d1/$e9/
  312.              $8b/$fb/$8b/$df/$83/$c7/$02/$26/$8b/$1f/$d1/$e3/$d1/$e3/$d1/$e3/
  313.              $03/$da/$be/$07/$00/$8a/$00/$d1/$c8/$88/$00/$4e/$79/$f7/$49/
  314.              $79/$e1/$1f);
  315.    end;
  316.  
  317. procedure bannerup(var shapes:charset; var msg:charmessage; length:integer);
  318.            { Rotate a banner 1 pixel up.  This routine changes the contents
  319.              of the character set, not the screen.  After the banner has been
  320.              rotated, it must be re-displayed for the change to be seen on the
  321.              screen }
  322.    begin
  323.       inline($1e/$c5/$7e/<shapes/$c4/$56/<msg/$8b/$4e/<length/$49/$78/$23/
  324.              $8b/$d9/$d1/$e3/$03/$da/$26/$8b/$1f/$d1/$e3/$d1/$e3/$d1/$e3/
  325.              $03/$df/$be/$07/$00/$8a/$00/$88/$20/$8a/$e0/$4e/$79/$f7/$88/
  326.              $67/$07/$49/$79/$dd/$1f);
  327.    end;
  328.  
  329. procedure bannerdown(var shapes:charset; var msg:charmessage; length:integer);
  330.            { Rotate a banner 1 pixel down.  This routine changes the contents
  331.              of the character set, not the screen.  After the banner has been
  332.              rotated, it must be re-displayed for the change to be seen on the
  333.              screen }
  334.    begin
  335.       inline($1e/$c5/$7e/<shapes/$c4/$56/<msg/$8b/$4e/<length/$49/$78/$26/
  336.              $8b/$d9/$d1/$d3/$03/$da/$26/$8b/$1f/$d1/$e3/$d1/$e3/$d1/$e3/
  337.              $03/$df/$83/$c3/$08/$be/$f8/$ff/$8a/$00/$88/$20/$8a/$e0/$46/
  338.              $75/$f7/$88/$67/$f8/$49/$79/$da/$1f);
  339.    end;
  340.  
  341. procedure columnup(var shapes:charset; var msg:charmessage; length:integer);
  342.            { Rotate a column 1 pixel up.  This routine changes the contents
  343.              of the character set, not the screen.  After the column has been
  344.              rotated, it must be re-displayed for the change to be seen on the
  345.              screen }
  346.    begin
  347.       inline($1e/$c5/$7e/<shapes/$c4/$56/<msg/$8b/$4e/<length/$49/$78/$2f/
  348.              $8b/$da/$26/$8b/$1f/$d1/$e3/$d1/$e3/$d1/$e3/03/$df/$8a/$27/
  349.              $8b/$d9/$d1/$e3/$03/$da/$26/$8b/$1f/$d1/$e3/$d1/$e3/$d1/$e3/
  350.              $03/$df/$be/$07/$00/$8a/$00/$88/$20/$8a/$e0/$4e/$79/$f7/$49/
  351.              $79/$e0/$1f);
  352.    end;
  353.  
  354. procedure columndown(var shapes:charset; var msg:charmessage; length:integer);
  355.            { Rotate a column 1 pixel down.  This routine changes the contents
  356.            of the character set, not the screen.  After the column has been
  357.            rotated, it must be re-displayed for the change to be seen on the
  358.            screen }
  359.    begin
  360.       inline($1e/$c5/$7e/<shapes/$c4/$56/<msg/$8b/$4e/<length/$49/$78/$36/
  361.              $8b/$d9/$d1/$e3/$03/$da/$26/$8b/$1f/$d1/$e3/$d1/$e3/$d1/$e3/
  362.              $03/$df/$8a/$67/$07/$8b/$da/$83/$c2/$02/$26/$8b/$1f/$d1/$e3/
  363.              $d1/$e3/$d1/$e3/$03/$df/$83/$c3/$08/$be/$f8/$ff/$8a/$00/$88/$20/
  364.              $8a/$e0/$46/$75/$f7/$49/$79/$de/$1f);
  365.    end;
  366.  
  367. procedure columnright(var shapes:charset; var msg:charmessage; length:integer);
  368.            { Rotate a column 1 pixel right.  This routine changes the contents
  369.              of the character set, not the screen.  After he column has been
  370.              rotated, it must be re-displayed for the change to be seen on the
  371.              screen }
  372.    begin
  373.       inline($1e/$c5/$7e/<shapes/$c4/$56/<msg/$8b/$4e/<length/$49/$78/$1c/
  374.              $8b/$d9/$d1/$e3/$03/$da/$26/$8b/$1f/$d1/$e3/$d1/$e3/$d1/$e3/
  375.              $03/$df/$be/$07/$00/$d0/$08/$4e/$79/$fb/$49/$79/$e4/$1f);
  376.    end;
  377.  
  378. procedure columnleft(var shapes:charset; var msg:charmessage; length:integer);
  379.            { Rotate a column 1 pixel left.  This routine changes the contents
  380.              of the character set, not the screen.  After the column has been
  381.              rotated, it must be re-displayed for the change to be seen on the
  382.              screen }
  383.    begin
  384.       inline($1e/$c5/$7e/<shapes/$c4/$56/<msg/$8b/$4e/<length/$49/$78/$1c/
  385.              $8b/$d9/$d1/$e3/$03/$da/$26/$8b/$1f/$d1/$e3/$d1/$e3/$d1/$e3/
  386.              $03/$df/$be/$07/$00/$d0/$00/$4e/$79/$fb/$49/$79/$e4/$1f);
  387.    end;
  388.